\ BANNER gst851114 : Banner ." MVP-FORTH is not optimized and is intended to introduce" cr ." you to FORTH. Mountain View Press is your FORTH SOURCE." cr ." Please call (415)961-4103 in the USA to order books," cr ." extensions and enhancements for use with MVP-FORTH." cr ." If you didn't buy this program from Mountain View Press" cr ." and find it of value, your financial contribution" cr ." to the author at the address below would be appreciated:" cr ." Fantasia Systems Inc." cr ." P. O. Box 5260" cr ." San Mateo, CA 94402" cr ; ( equates for ascii characters mvp-forth) hex 20 equ bl ( an ascii blank ) 0d equ cr ( an ascii carriage return ) 2d equ minus ( an ascii minus ) 2e equ dot ( an ascii . ) 07 equ beep ( an ascii control g or bell ) 0a equ lf ( an ascii line feed ) 0c equ ff ( an ascii form feed ) 7f equ del ( an ascii delete ) 10 equ dle ( an ascii ^p ) 08 equ bsout ( an ascii backspace sent to keyboard ) 08 equ bsin ( an ascii backspace sent from keyboard ) \ mvp-forth - cross-compile load screen gst851223 hex " mvp.amg" initiate \ object to go here !! cross-compile swap-bytes align \ -4 d000 org/img \ set host origin -4 so next=0(bp) -4 0 on3 dup . org/db \ disk on next drive fff0 equ em ( set host end of memory ) \ decimal 4 131 hex thru is-fence finis decimal ( compute the first disk buffers address mvp-forth) 404 equ hdbt ( specify the size of disk buffer head, buffer and tail ) 2 equ nbuf ( specify the number of buffers required. ) em hdbt nbuf * - equ buf1 ( compute the absolute address of the first disk buffer. ) \ compute the initial stack addresses gst850921 52 equ us ( set the size of the user area. ) buf1 us - equ init-r0 ( compute the absolute address of the initial return stack. ) 60 equ rts ( set the size of the return stack and terminal input buffer. ) \ no rp, but used as tib (normally a0) init-r0 rts - equ init-sp0 ( compute the absolute address of the initial parameter stack. ) \ >next< incomingsp forth entry point gst851106 assembler \ entry here then bra beyond user area init 3000 bra here 2- \ 16 bit displacement \ this bra's *very* far !!!!!!! must be 4 bytes !!!! \ next *must* be here, this is where the base pointer \ points so next can jmp via bp with no displacement here label >next< \ special label for single next ip )+ w move 0 w bp di.l) os move 0 os bp di.l) jmp forth here label incomingsp 0 , 0 , \ daddr of incoming sp \ user area initialization 1 of 2 gst850914 here label init-forth 0 , ( initial pointer to the top entry in forth voc ) here label init-user init-sp0 , ( parameter stack address sp0 ) init-r0 , ( return stack address r0 ) \ not used !! init-sp0 , ( terminal input buffer address ) 01f , ( name field width in bytes ) 1 , ( error warning mode ) here label init-fence 0 , ( fence address for forgetting dictionary entries ) here label init-dp 0 , ( initial dictionary pointer ) here label init-voc-link 0 , ( initial vocabulary link ) \ user area initialization: <words> gst850914 ] <-find> <?terminal> <abort> <block> <cr> <emit> <expect> <interpret> <key> <load> <number> <page> <r/w> <type> <vocabulary79> <word> [ \ user and return stack pointers gst851106 here label up init-r0 , ( user pointer. ) here label rpp init-r0 , ( return stack pointer. ) \ here, but not used !!!! \ ExecBase GfxBase DosBase MyRaster Registers gst851223 \ These are names to use for common library base values. create ExecBase 0 , 0 , \ EXEC library pointer (from 4) create GfxBase 0 , 0 , \ graphics.library base create DosBase 0 , 0 , \ dos.library base create IntuBase 0 , 0 , \ intuition.library base create REGISTERS 40 allot \ 16 regs x 4 bytes create Arguments \ incoming arguments when pgm invoked 0 , 0 , \ pointer ( incoming A0 ) 0 , \ length ( incoming D0 ) create WBmsg 0 , 0 , \ if under WB, msg to reply on BYE create ThisTask 0 , 0 , \ will be addr to this task \ "Register Stuffing" gst850930: Get.Reg# ( -- <digit> regaddr \ parses out a digit ) bl word dup count >Uppercase 1+ c@ 10 digit 0= abort" Huh?" 4 * Registers + ; : Tagged? ( c -- f ) here 2+ c@ = here c@ 1 > and ; : WhichReg ( -- regaddr ) Get.Reg# chr W tagged? chr B tagged? or if compile LITW! else chr L tagged? if compile LIT! 2+ else chr X tagged? if compile LITX! else chr H tagged? if compile LIT! else compile LIT2! then then then then ; \ W or B pads 0 in high, L and H stuff half the reg \ X forces sign extension \ >RD >RA LVO, EXEC: DOS: : >RD WhichReg , ( offset) ; immediate : >RA WhichReg 32 + , ( offset to A regs) ; immediate : LVO, ( -- <hexnum> hexnum ) base @ >R [compile] hex bl word dup count >Uppercase number drop r> base ! , ; : EXEC: ( -- <LVO> ) \ compile an EXEC call compile LIBRARY: ExecBase , LVO, ; immediate : DOS: ( -- <LVO> ) \ compile a DOS call compile LIBRARY: DosBase , LVO, ; immediate \ used: : FOO ... >RA 1 >RD 0W DOS: FFE0 RESULT ... ; \ mountian view press forth entry point gst851223assembler \ entry bra's to here here label 'cold ] cold [ \ first thing to next to forth \ this pairs with a bra a few screens back !!!! here over - swap ! \ 16 bit displaced bra assembler \ save incoming regs, then set up forth regs 48e7 , 7ffe , \ movem d1-d7/a0-a6,-(rp) save all regs w long clr os long clr word \ init work regs here 2+ negate pcd) bp lea \ setup base pointer a0 arguments bp d) lmove d0 arguments 4 + bp d) move 'cold bp d) ip lea \ init ip too init-user bp d) w move 0 w bp di.l) sp lea rp incomingsp bp d) long move word \ save original real sp next forth \ lit! lit2! litw! litx! gst851001 code lit! ( value -- [addr] \ store value at addr ) ip )+ os move sp )+ 0 os bp di.l) move next end-code code lit2! ( dvalue -- [addr] \ store double num at addr ) ip )+ os move sp )+ 0 os bp di.l) long move word next end-code code litw! ( value -- [addr] \ 2!, padding with 0 ) ip )+ os move sp )+ w move w 0 os bp di.l) long move word next end-code code litx! ( value -- [addr] \ do a 'sign extending' 2! ) ip )+ os move sp )+ a0 move a0 0 os bp di.l) long move word next end-code \ resident library interfacing gst851106assembler here label librts \ the rts from library: lands here!! 4cdf , 7cf0 , \ movem (rp)+,d4-d7/a2-a6 4 ip long addq word next \ library: is done, we can go on code library: ( -- [libbase] [lvo] d0 \ call a library) 48e7 , 0f3e , \ movem d4-d7/a2-a6,-(rp) ip )+ os move 0 os bp di.l) a0 long move word ip )+ d0 move d0 long ext a0 a6 long move word librts bp d) pea 0 d0 a6 di.l) pea 4ceb , 3fff , registers , \ movem registers(bp),d0-d7/a0-a5 rts end-code \ return to the pushed address in the lib \ note: we assume that d0 is preserved thru next, so that \ the library: can be followed immediately by result \ result a>l 2@l 2!l gst851001 code result ( -- dresult \ push d0 after a library: ) d0 sp -) long move word next end-code code a>l \ addr -- longaddr | convert to absolute addr sp )+ os move 0 os bp di.l) a1 lea a1 sp -) long move word next end-code code 2@l \ daddr - d | long double fetch long sp )+ a0 move a0 ) sp -) move word next end-code code 2!l \ d daddr -- | long double store long sp )+ a0 move sp )+ a0 ) move word next end-code \ !l @l c!l c@l gst851001 code !l sp )+ a0 lmove sp )+ a0 ) move next end-code code @l sp )+ a0 lmove a0 ) sp -) move next end-code code c!l sp )+ a0 long move word sp )+ d0 move d0 a0 ) byte move word next end-code code c@l sp )+ a0 long move d0 clr a0 ) d0 byte move word d0 sp -) move next end-code \ <bye> ((")) gst851223 code <bye> \ actually used to return to caller incomingsp bp d) rp long move word \ get original real sp 4cdf , 7ffe , \ movem (rp)+,d1-d7/a0-a6 restore regs d0 long clr word rts end-code code ((")) \ used in a : definition only!!! rp ) os move d0 long clr word \ os=addr of string 0 os bp di.l) d0 byte move word \ d0=count (w/out null) d0 d1 long move os d1 add word \ d1=next rp value 3 d1 addq ( for null + length byte + 1 to and ) fffe # d1 and d1 rp ) move \ update and aligned 1 os addq os sp -) move ( addr ) d0 sp -) move ( count ) next end-code \ +Null (") (,") " gst851106 : +Null ( addr # -- addr # ) \ place a null at end of string 2dup + 0 swap c! ; \ force a null at end of " : (") ((")) ; ( -- addr count ) \ using our primitive : (,") ( -- | ..." |) \ # & string w/null & aligned at end! 22 word count +null 2+ allot aligned drop ; : " \ -- addr count || ..." | string state smart uses PAD state @ IF compile (") (,") \ get strng ELSE 22 word count +null \ string not compiled >R pad r@ 1+ cmove pad r> \ at PAD THEN ; immediate \ if not compiled, string at PAD !!!! \ StdIn StdOut AltOut "Dos" "Gfx" "Raw" gst851223 create StdIn 0 , 0 , create StdOut 0 , 0 , create AltOut 0 , 0 , \ you make it whatever you want : "Dos" " dos.library" ; \ so you can easily change it : "Gfx" " graphics.library" ; : "Raw" " RAW:0/0/640/200/MVP-FORTH Fantasia Systems Inc. Glenn Tenney 851223" ; \ openlibrary open close read write gst851106 : openlibrary \ addr # version -- dbase | open that library >rd 0w +null drop a>l >ra 1 exec: fe68 result ; : open \ addr # mode -- dfile | opens file >rd 2x +null drop a>l >rd 1 dos: ffe2 result ; : close >rd 1 dos: ffdc ; \ dfile -- | close it : read \ dbuf len dfile -- real-len | read len bytes >rd 1 >rd 3w >rd 2 dos: ffd6 result drop ; : write \ dbuf len dfile -- real-len | write len bytes >rd 1 >rd 3w >rd 2 dos: ffd0 result drop ; \ ioerr seek debug gst851106 : ioerr dos: ff7c result drop ; \ -- error# | : seek \ doffset dfile mode -- dbyte# | >rd 3x >rd 1 >rd 2 dos: ffbe result ; : debug exec: ff8e ; \ enter romwack \ <key> <?terminal> <type> <emit> gst851106: <key> 0 sp@ 1+ ( read char onto stack ) a>l 1 stdin 2@ read drop ; : <?terminal> stdin 2@ >rd 1 \ do waitforchar 0 >rd 2w dos: ff34 result drop ; : <type> \ addr count -- | send that string dup out +! ( update counter ) >r a>l 2dup r@ stdout 2@ write drop \ std output r> eprint @ if \ echo to another file? altout 2@ or \ see if any handle there if altout 2@ write drop exit then then 2drop drop ; \ done w/ daddr and length : <emit> sp@ 1+ 1 <type> drop ; \ c -- | \ (open) FileTable gst851223 : (open) \ addr count mode -- dhandle | validated open dup new = over old = or 0= Abort" Invalid mode" >r 2dup + c@ Abort" Invalid filename" r> Open 2dup or 0= Abort" Open error" ; create FileTable \ dhandle length filename FileWidth maxfile * allot \ room for fileinfo \ FileHandle/Size/Name Select File0 File1 gst851223: FileHandle \ n -- addr | pt to file dhandle file n maxfile 1- over u< abort" Invalid file number" FileWidth * filetable + ; : FileSize \ n -- addr | pt to size of file n in blocks filehandle 4 + ; \ leaving a couple of words here for possible extensions : FileName \ n -- addr | pt to count byte of name FileSize 6 + ; : Select \ n -- | set offset for appropriate file n blocks/file * offset ! ; : File0 0 select ; : File1 1 select ; \ File# NextFile FileSize! gst851223 : File# \ -- n | what file number is current offset @ blocks/file / ; : NextFile \ -- n | next avail file (fm 0) or -1 if none -1 MaxFile 0 DO I FileHandle 2@ or 0= IF drop I leave THEN LOOP ; \ leave n : FileSize! \ n -- | get size of file n in blocks and set it dup FileHandle 2@ 2dup or IF \ if file there 0. 2over Offset_End Seek 2drop \ DOS is WRONG!!! 0. 2swap Offset_End Seek \ this is really answer 400 ( 1024 ) u/mod swap drop \ file# #blocks ELSE drop THEN \ file handle is 0 which is its size swap FileSize ! ; \ set size of file in blocks \ Files CloseFile (file) gst851223: Files \ -- | show all files MaxFile 0 DO cr File# i = if ." *" else space then ." File" i 3 .r space i filehandle 2@ or IF i filename count type \ file is open i filesize @ 5 .r ." blocks" THEN LOOP cr ; : CloseFile \ n -- | close file n save-buffers 0 over filename c! ( count=0 1st is ok ) filehandle dup 2@ 2dup or if close empty-buffers else 2drop then 0 0 rot 2! ; \ mark it closed : (file) \ -- addr # | get file name from input stream bl word count +null ; \ just get name \ SetFile FILE CloseAlt Alternate gst851223: SetFile \ addr count dhandle -- | set this as current file File# dup CloseFile ( make sure ) dup >r FileHandle 2! 30 min ( max length ) dup r@ FileName c! ( stuff count byte ) r@ FileName 1+ swap 1+ cmove ( get rest of name+null ) r> FileSize! ( finally set its size ) ; : FILE \ addr count mode -- | make this current file >r 2dup r> (open) SetFile ; \ make it current file : CloseAlt \ -- | close AltOut if open AltOut 2@ 2dup or if Close 0. AltOut 2! else 2drop then ; : Alternate \ addr count mode -- | open and set AltOut CloseAlt (open) AltOut 2! ; \ handle stored \ CloseAll From Include gst851223\ These functions should be common with other implementations. : CloseAll \ -- | close all open blocks files MaxFile 0 DO i CloseFile LOOP ; : From \ -- | <name> blank delim'ed made current file (file) Old File ; \ must already exist : Include \ -- | <name> || 1 load from that file then close NextFile dup 0< Abort" No room for another file" >R (file) 2dup Old (open) ( open file ) r> File# >r Select ( new ) SetFile ( from new ) 1 load File# CloseFile r> Select ; \ back \ " foo" old file .or. " foo" new file \ from foo .or. include foo ( to 1 load then close ) \ Larger gst851223 : Larger \ n -- | makes current file0 n blocks larger 1 ?enough \ must have one thing on stack Save-Buffers ( be sure ) File# ( use this file ) FileHandle 2@ 2dup or IF ( only if there is one ) 7FFF buffer 400 bl fill ( will be a work area ) 0. 2swap Offset_end seek 2drop ( pt at end ) 0 DO 7FFF block A>L ( use work area ) 400 File# filehandle 2@ write ( write 1k ) 400 - abort" Error enlarging file" LOOP File# FileSize! empty-buffers ELSE 2drop drop THEN ; \ otherwise nada \ used like: 0 select 5 larger \ to make file0 5 blocks larger, must be current and file0 \ ColdSwitch OpenConsole OpenLibraries wb? gst851223 create ColdSwitch 0 , \ 0=do cold once only : OpenConsole \ -- | open stdin/out for console i/o "raw" Old open 2dup StdIn 2! StdOut 2! 0 0 AltOut ! ; \ and close out alt file : OpenLibraries \ -- | open desired libraries "dos" 0 openlibrary dosbase 2! ( dos library ) "gfx" 0 openlibrary gfxbase 2! ( gfx library ) ; : WB? \ -- f | t if running under WorkBench pr_CLI<>0 ThisTask 2@ 0AC ( pr_CLI ) 0 d+ 2@L or 0= ; B amigacold 930201jb : amigacold \ -- | done only once until execbase set coldswitch @ 0= if \ do this once only 1 coldswitch ! \ set to not do this again filetable filewidth maxfile * 0 fill \ files all closed 4. 2@l execbase 2! \ set execbase openlibraries \ always need to do this 0 >ra 1w exec: feda ( 0 findtask ) result thistask 2! \ set ptr to our own task wb? if \ using pr_msgport equivalent of waitmsg thistask 2@ 5c 0 d+ 2dup >ra 0 exec: fe80 >ra 0 exec: fe8c result wbmsg 2! \ ptr to msg then openconsole \ also always needed then ; \ ! # #> #s ' gst851106 code ! \ sp must not be a7 !!!! sp )+ os move sp )+ 0 os bp di.l) byte move \ byte 1 sp )+ 1 os bp di.l) move word next end-code : # base @ m/mod rot 9 over < if 7 + then 30 + hold ; : #> 2drop hld @ pad over - ; : #s begin # 2dup or not until ; : ' -find not abort" not found" drop [compile] literal ; immediate \ constants decimal 1005 constant Old 1006 constant New hex 0 constant 0 1 constant 1 2 constant 2 20 constant bl 40 constant c/l 8 constant MaxFile em constant limit up constant up \ user pointer nbuf constant #buff buf1 constant first init-forth constant init-forth init-user constant init-user 3e8 constant Blocks/File \ max 1000 blocks/file 2A constant FileWidth \ width of table 42 -1 constant Offset_Beginning 0 constant Offset_Current 1 constant Offset_End \ system variables variable use first use ! variable prev first prev ! variable disk-error 0 disk-error ! variable eprint 0 eprint ! variable caps 1 caps ! \ 1 is case insensitive \ 0 is case sensitive \ user variables and 'vectors hex 00 user ??? 02 user rpp?? 04 user dp 06 user sp0 08 user r0 0a user tib 0c user width 0e user warning 10 user fence 12 user dp 14 user voc-link 16 user '-find 18 user '?terminal 1a user 'abort 1c user 'block 1e user 'cr 20 user 'emit 22 user 'expect 24 user 'interpret 26 user 'key 28 user 'load 2a user 'number 2c user 'page 2e user 'r/w 30 user 'type 32 user 'vocabulary 34 user 'word 36 user >in 38 user base 3a user blk 3c user context 3e user csp 40 user current 42 user dpl 44 user fld 46 user hld 48 user offset 4a user out 4c user r# 4e user scr 50 user state \ 'stream 'warm ( * */ */mod gst851223 : 'stream blk @ ?dup if block else tib @ then >in @ + ; create 'warm ] <warm> [ \ to easily re-vector !! : ( -1 >in +! 29 word c@ 1+ here + c@ 29 = not ?stream ; immediate : * u* drop ; : */ */mod swap drop ; : */mod >r m* r> m/ ; \ + +! +- +buf gst851001 code + sp )+ d0 move d0 sp ) add next end-code code +! sp )+ w move 0 w bp di.l) a1 lea \ real addr a1 )+ w byte move word 8 # w lsl a1 ) w byte move word sp )+ w add w a1 ) byte move word 8 # w lsr w a1 -) byte move word next end-code : +- 0< if negate then ; : +buf hdbt + dup limit = if drop first then dup prev @ - ; \ +loop , - -find -trailing . gst850915 : +loop 3 ?pairs compile <+loop> here - , ; immediate : , here ! 2 allot ; code - sp )+ d0 move d0 sp ) sub next end-code : -find '-find @ execute ; : -trailing dup 0 do 2dup + 1- c@ bl - if leave else 1- then loop ; : . s->d d. ; \ ." .line .r / /loop /mod gst851106 : ." 'stream c@ 22 = if 1 >in +! else state @ if compile <."> (,") else 22 word dup c@ 1+ over + c@ 22 = not ?stream count type then then ; immediate : .line <line> -trailing type ; : .r >r s->d r> d.r ; : / /mod swap drop ; : /loop 3 ?pairs compile </loop> here - , ; immediate : /mod >r s->d r> m/ ; \ 0< 0= 0> 0branch 1+ 1- gst851001 code 0< sp ) tst d0 smi 1 d0 andi d0 sp ) move next end-code : 0= not ; : 0> 0 > ; code 0branch sp )+ d0 move 0<> if 2 ip long addq word \ bump over if <> else ip ) a0 move a0 ip long adda word then next end-code code 1+ 1 sp ) addq next end-code code 1- 1 sp ) subq next end-code \ 2* 2+ 2- 2/ code 2* sp ) asl next end-code code 2+ 2 sp ) addq next end-code code 2- 2 sp ) subq next end-code code 2/ sp ) asr next end-code \ 2@ 2! gst851106 code 2@ \ addr -- d | get doublword even on byte boundary sp )+ os move \ read a byte at a time (slow but !!) 3 os bp di.l) sp -) byte move 2 os bp di.l) sp -) byte move 1 os bp di.l) sp -) byte move 0 os bp di.l) sp -) byte move word next end-code code 2! \ d addr -- | must be on word boundary !! sp )+ os move \ store a byte at a time too!! sp )+ 0 os bp di.l) byte move sp )+ 1 os bp di.l) byte move sp )+ 2 os bp di.l) byte move sp )+ 3 os bp di.l) byte move word next end-code \ 2drop 2dup 2over 2swap 79-standard : ; gst851001 code 2drop 4 sp long addq word next end-code code 2dup sp ) sp -) long move word next end-code code 2over 4 sp d) sp -) long move word next end-code code 2swap long sp )+ d0 move sp ) d1 move d0 sp ) move d1 sp -) move word next end-code : 79-standard ; : : sp@ csp ! current @ context ! create smudge ] ;code ip d0 long move bp d0 long sub word \ cnvrt to forth addr d0 rp -) move 2 w bp di.l) ip lea next end-code : ; ?csp compile exit smudge [compile] [ ; immediate \ < <# <+loop> code < sp )+ sp )+ cmpm d0 slt 1 d0 andi d0 sp -) move next end-code : <# pad hld ! ; code <+loop> sp )+ d0 move < if d0 rp ) add rp ) d0 move 2 rp d) d0 cmp < if 4 rp long addq 2 ip addq word else ip ) a0 move a0 ip long adda word then else d0 rp ) add rp ) d0 move 2 rp d) d0 cmp < if ip ) a0 move a0 ip long adda word else 4 rp long addq 2 ip addq word then then next end-code \ <-find> <."> </loop> : <-find> token context @ @ <find> ; : <."> ((")) type ; \ show that string code </loop> sp )+ d0 move d0 rp ) add rp ) d0 move 2 rp d) d0 cmp carry if \ not done ip ) a0 move a0 ip long adda word else 4 rp long addq 2 ip addq word then next end-code \ <;code> <<cmove> <abort"> <abort> gst850920 : <;code> r> latest pfa cfa ! ; code <<cmove> d0 long clr word \ for later sp )+ d0 move sp )+ os move 0 os bp di.l) a0 lea sp )+ os move 0 os bp di.l) a1 lea \ a1=fm a0=to d0=# long d0 a0 adda d0 a1 adda word \ pt to end begin 1 d0 subq 0>= while a1 -) a0 -) byte move word repeat next end-code : <abort"> if where cr r@ count type sp! quit else r> dup c@ + 1+ dup 1 and + >r then ; : <abort> sp! ?stack [compile] forth definitions quit ; \ <block> <cmove : <block> offset @ + >r prev @ dup @ r@ - 2* if begin +buf not if drop r@ buffer dup r@ 1 r/w 2- then dup @ r@ - 2* not until dup prev ! then r> drop 2+ ; : <cmove dup 1 < if 2drop drop else <<cmove> then ; \ <cmove> <cr> <do> gst851001 code <cmove> sp )+ d0 move sp )+ os move 0 os bp di.l) a0 lea sp )+ os move 0 os bp di.l) a1 lea \ a1=fm a0=to d0=# begin 1 d0 subq 0>= while a1 )+ a0 )+ byte move word repeat next end-code decimal : <cr> 13 emit 10 emit 0 out ! ; hex code <do> sp )+ rp -) long move word next end-code \ <expect> <fill> gst850902 : <expect> over + over do key dup bsin = over del = or if drop dup i = dup r> 2- + >r if beep else bsout dup emit 20 emit then else dup 0d = if leave drop bl 0 else dup then i c! 0 i 1+ ! then emit 1 /loop drop ; code <fill> sp )+ d1 move sp )+ d0 move sp )+ os move 0 os bp di.l) a1 lea begin 1 d0 subq 0>= while d1 a1 )+ byte move word repeat next end-code \ <find> first screen gst851001 code <find> sp )+ os move 0 os bp di.l) a0 lea sp )+ os move 0 os bp di.l) a2 lea d0 clr d1 clr d2 clr ( flag ) w clr ( traverse? ) begin a2 a1 long move ( a1=crnt str a0=crnt nfa ) forth \ notice !!! <find> is huge and overflows a block !!!!! \ It is continued on the next screen. \ <find> ... continued ... !!!!! gst851001assembler byte a1 )+ d0 move a0 )+ d1 move d1 os word move byte 1f # d0 and 3f # d1 and ( leave smudge bit ) word begin d0 d1 cmp ( char =? ) 0= while 1 w moveq byte a1 )+ d0 move a0 )+ d1 move word repeat 7f # d1 byte and word d0 d1 cmp 0<> if w a0 long suba word ( -1 if after len byte ) begin a0 )+ byte tst word 0< until then a0 d3 long move 1 d3 addq fe # d3 byte and d3 a0 long move word \ lfa is next word after nfa d0 d1 cmp ( was it found? ) 0= if ( yes ) bp a0 long suba word 4 a0 addq a0 sp -) move ( pfa ) word os sp -) move ( len ) 1 d2 moveq ( flag ) os clr ( set zero to stop loop ) else w clr a0 ) os move 0 os bp di.l) a0 lea then 0= until ( til end ) d2 sp -) move next end-code \ <interpret> <line> <load> gst850902 : <interpret> begin -find if state @ < if cfa , else cfa execute then else here number dpl @ 1+ if [compile] dliteral else drop [compile] literal then then ?stack again ; : <line> block swap c/l * + c/l ; : <load> ?dup not abort" unloadable" blk @ >r >in @ >r 0 >in ! blk ! interpret r> >in ! r> blk ! ; \ <loop> <number> <page> gst851001 code <loop> 1 rp ) addq rp ) d0 move \ loop by one get index 2 rp d) d0 cmp < if ip ) a0 move a0 ip long adda word else 4 rp long addq 2 ip addq word then next end-code : <number> 0 0 rot dup 1+ c@ minus = dup >r + -1 dpl ! convert dup c@ bl > if dup c@ dot = not abort" not recognized" 0 dpl ! convert dup c@ bl > abort" not recognized" then drop r> if dnegate then ; : <page> 12 emit ; \ <r/w> <vocabulary79> <vocabularyfig> gst851223 : <r/w> \ addr blk f -- | f=0 write f=1 read block >r blocks/file /mod \ addr blk file# -- | dup filehandle 2@ 2dup or 0= abort" file not open" 2swap filesize @ 1- over < abort" block not within file" 400 u* 2over offset_beginning seek 2drop rot a>l 2swap 400 rot rot \ daddr len dfile -- r> if read else write then 400 swap - disk-error ! ; : <vocabulary79> create 81 c, a0 c, ' forth , here voc-link @ , voc-link ! does> 2+ context ! ; : <vocabularyfig> create 81 c, a0 c, current @ cfa , here voc-link @ , voc-link ! does> 2+ context ! ; \ <warm> <word> = > >r gst851223 : <warm> \ final part of cold page ." mvp-forth version 1.00.03a amiga" cr cr banner abort ; : <word> 'stream swap enclose 2dup > if 2drop 2drop 0 here ! else >in +! over - dup >r here c! + here 1+ r> dup ff > abort" input > 255" 1+ cmove then here ; : = - not ; : > swap < ; code >r sp )+ rp -) move next end-code \ >uppercase ? ?comp gst851001 code >uppercase \ addr count -- | converts chars to upper sp )+ d0 move sp )+ os move 0 os bp di.l) a0 lea here byte a0 ) os move ascii a os cmpi >= if ascii z os cmpi <= if 0df os andi then then os a0 )+ move d0 dbra next end-code : ? @ . ; : ?comp state @ not abort" compile only" ; \ ?csp ?dup ?enough ?loading ?pairs : ?csp sp@ csp @ - abort" definition not finished" ; : ?dup dup if dup then ; : ?enough ( n -- ) \ abort if not >= n items on stack depth 1- > abort" not enough items on stack" ; : ?loading blk @ not abort" loading only" ; : ?pairs - abort" conditionals not paired" ; \ ?stack ?stream ?terminal @ : ?stack sp@ s0 swap u< abort" stack out of bounds" sp@ here 80 + u< abort" stack full" ; : ?stream abort" input stream exhausted" ; : ?terminal '?terminal @ execute ; code @ sp ) os move 0 os bp di.l) 0 sp d) byte move word 1 os bp di.l) 1 sp d) byte move word next end-code \ abort abort" abs aligned : abort 'abort @ execute ; : abort" ?comp compile <abort"> 'stream c@ 22 = if 1 >in +! 0 c, else 22 word dup c@ 1+ swap over + c@ 22 = not ?stream allot aligned then ; immediate : abs dup +- ; : aligned here 1 and if 0 c, then ; \ again allot and begin blank block : again 1 ?pairs compile branch here - , ; immediate : allot dp +! ; code and sp )+ d0 move d0 sp ) and next end-code : begin ?comp here 1 ; immediate : blank bl fill ; : block 'block @ execute ; \ branch buffer bye gst851223 code branch ip ) a0 move a0 ip long adda word next end-code : buffer use @ prev @ = if use @ +buf drop use ! then use @ dup >r begin +buf until use ! r@ @ 0< if r@ 2+ r@ @ 7fff and 0 r/w then r@ ! r@ prev ! r> 2+ ; : bye freeze closeall closealt stdout 2@ close \ close everything! wb? if exec: ff7c ( forbid -- required !!! ) wbmsg 2@ >ra 1 exec: fe86 ( replymsg ) then <bye> ; \ and finally return to caller rc=0 \ 0 >rd 1x dos: ff70 ; \ and return code = 0 \ c! c, c@ cfa clear gst851001 code c! sp )+ os move sp )+ d0 move d0 0 os bp di.l) byte move word next end-code : c, here c! 1 allot ; code c@ sp )+ os move d0 clr 0 os bp di.l) d0 byte move word d0 sp -) move next end-code : cfa 2- ; : clear offset @ + buffer 400 bl fill update ; \ change cmove cold compile gst851223 : change freeze limit hdbt #buff * - dup ' first ! us - dup rts - dup init-user ! [ init-user 4 + ] literal ! dup [ init-user 2+ ] literal ! up over rpp origin here ! here rot rot ! rot rot ! execute ; : cmove dup 1 < if 2drop drop else <cmove> then ; : cold amigacold \ first special init code empty-buffers init-user up @ 6 + us 6 - cmove first use ! first prev ! file0 0 eprint ! init-forth @ ' forth 2+ ! decimal warm ; : compile ?comp r> dup 2+ >r @ , ; \ constant convert count cr gst851001 : constant create , ;code 2 w bp di.l) sp -) move next end-code : convert begin 1+ dup >r c@ base @ digit while swap base @ u* drop rot base @ u* d+ dpl @ 1+ if 1 dpl +! then r> repeat r> ; : count dup 1+ swap c@ ; : cr 'cr @ execute ; \ create gst851106 : create here dup -find if 1f and 0= abort" attempted to redefine 'null'" drop warning @ if dup count type space ." isn't unique " then then c@ width @ min 1+ allot dup 80 toggle here 1- 80 toggle aligned latest , 2 allot current @ ! ;code 2 w addq w sp -) move next end-code \ d+ d+- d. d.r d< dabs gst851223 code d+ sp )+ d0 long move d0 sp ) long add word next end-code : d+- 0< if dnegate then ; : d. 0 d.r space ; : d.r 3 ?enough \ depth 3 < abort" empty stack" >r swap over dup d+- <# #s rot sign #> r> over - spaces type ; : d< rot 2dup = if rot rot dnegate d+ 0< else swap < swap drop then swap drop ; : dabs dup d+- ; \ decimal definitions depth digit gst851106 : decimal 0a base ! ; : definitions context @ current ! ; : depth sp@ s0 swap - 2/ ; code digit sp )+ d0 move sp ) d1 move 30 # d1 sub 0< if here label digitbad sp ) clr else 0a d1 cmpi 0>= \ true if not decimal if 11 d1 cmpi digitbad bmi \ '9'-'a' bad 7 d1 subq then \ 'a'-'~' into 10 .. d0 d1 cmp digitbad bpl \ error if over base d1 sp ) move 1 # sp -) move then next end-code \ dliteral dnegate do gst851106 : dliteral state @ if swap [compile] literal [compile] literal then ; immediate code dnegate sp ) long neg word next end-code : do compile <do> here 3 ; immediate \ dodoes (does>) does> gst851106 \ achtung!! dodoes must be w/in 1st 32k of dictionary !!!!!! assembler here label dodoes ip d0 long move bp d0 long sub rp )+ ip long move word d0 rp -) move 2 w addq w sp -) move next forth : (does>) \ so user code can generate the does call compile [ 4eab , ] compile [ dodoes , ] ; : does> ?csp compile <;code> \ set up so it later does ;code (does>) ; immediate \ lay down a jsr dodoes \ drop dup else emit empty-buffers gst850930 code drop 2 sp long addq word next end-code code dup sp ) sp -) move next end-code : else 2 ?pairs compile branch here 0 , swap 2 [compile] then 2 ; immediate : emit 'emit @ execute ; : empty-buffers first limit over - 0 <fill> #buff 0 do 7fff hdbt i * first + ! loop ; \ enclose gst851001 code enclose sp )+ d0 move ( char ) sp ) os move ( addr ) 0 os bp di.l) a0 lea -1 # d1 move ( n ) begin 1 d1 addq a0 )+ d2 byte move d2 d0 cmp word 0<> until d1 sp -) move ( n1 ) d2 byte tst word 0= if d1 d0 move 1 d1 addq ( 1st char=null ) else here label 1encl ( like begin ) 1 d1 addq a0 )+ d2 byte move d2 d0 cmp word 0= if d1 d0 move 1 d0 addq ( found terminator ) else d2 byte tst 1encl bne ( no term, not null ) word d1 d0 move ( found null before terminator ) then then d1 sp -) move d0 sp -) move ( n2 n3 ) next end-code \ execute exit expect fill find gst851001 code execute sp )+ w move 0 w bp di.l) os move 0 os bp di.l) jmp end-code code exit rp )+ os move 0 os bp di.l) ip lea ip )+ w move 0 w bp di.l) os move 0 os bp di.l) jmp end-code : expect 'expect @ execute ; : fill over 0> if <fill> else 2drop drop then ; : find -find if drop cfa else 0 then ; \ forget gst850927 : forget token current @ @ <find> 0= abort" not in current vocabulary" drop nfa dup fence @ u< abort" in protected dictionary" >r r@ context @ u< if [compile] forth then r@ current @ u< if [compile] forth definitions then voc-link @ begin r@ over u< while @ repeat dup voc-link ! begin dup 4 - begin pfa lfa @ dup r@ u< until over 2- ! @ ?dup 0= until r> dp ! ; \ forth freeze here hex hold if immediate gst850902 vocabulary forth immediate : freeze up @ 6 + init-user 30 cmove ' forth 2+ @ init-forth ! ; : here dp @ ; : hex 10 base ! ; : hold -1 hld +! hld @ c! ; : if compile 0branch here 0 , 2 ; immediate : immediate latest 40 toggle ; \ i i' interpret j key latest leave gst850902 code i rp ) sp -) move next end-code code i' 2 rp d) sp -) move next end-code : interpret 'interpret @ execute ; code j 4 rp d) sp -) move next end-code : key 'key @ execute ; : latest current @ @ ; code leave rp ) d0 move d0 2 rp d) move next end-code \ lfa list lit literal load loop gst850902 : lfa 4 - ; : list cr dup scr ! ." scr #" u. 10 0 do cr r@ 3 .r space r@ scr @ .line ?terminal if leave then loop cr ; code lit ip )+ sp -) move next end-code : literal state @ if compile lit , then ; immediate : load 'load @ execute ; : loop 3 ?pairs compile <loop> here - , ; immediate \ m* m*/ m+ m/ m/mod gst850924 : m* 2dup xor >r abs swap abs u* r> d+- ; : m*/ 2dup xor swap abs >r swap abs >r over xor rot rot dabs swap r@ u* rot r> u* rot 0 d+ r@ u/mod rot rot r> u/mod swap drop swap rot d+- ; : m+ s->d d+ ; : m/ over >r >r dup d+- r@ abs u/mod r> r@ xor +- swap r> +- swap ; : m/mod >r 0 r@ u/mod r> swap >r u/mod r> ; \ max min mod move negate nfa not gst850924 : max 2dup < if swap then drop ; : min 2dup > if swap then drop ; : mod /mod drop ; : move 0 max 2* <cmove> ; code negate sp ) d0 move d0 neg d0 sp ) move next end-code : nfa 5 - -1 traverse ; code not sp ) tst d0 seq 1 d0 andi d0 sp ) move next end-code \ number or over pad gst850902 : number 'number @ execute ; code or sp )+ d0 move d0 sp ) or next end-code code over 2 sp d) sp -) move next end-code : pad here 44 + ; \ page pfa pick pp query quit gst850924 : page 'page @ execute ; : pfa 1 traverse 6 + -2 and ( to word aligned ) ; : pick dup 1 < abort" pick argument < 1" 2* sp@ + @ ; : pp dup fff0 and abort" off screen" 1 text pad 1+ swap scr @ <line> cmove update ; : query tib @ 50 expect 0 >in ! ; : quit 0 blk ! [compile] [ begin cr rp! query interpret state @ not if ." ok" then again ; \ r/w r> r@ repeat gst850902 : r/w 'r/w @ execute ; code r> rp )+ sp -) move next end-code code r@ rp ) sp -) move next end-code : repeat >r >r [compile] again r> r> 2- [compile] then ; immediate \ roll rot rp! gst851001 : roll dup 1 < abort" roll argument < 1" 1+ dup pick swap 2* sp@ + begin dup 2- @ over ! 2- sp@ over u< not until 2drop ; code rot sp )+ d0 long move word sp )+ d1 move d0 sp -) long move word d1 sp -) move next end-code code rp! incomingsp bp d) rp long move word \ save original real sp 20 rp long subq word ( leave some room ) next end-code \ s->d s0 save-buffers sign smudge sp! gst851106 code s->d sp )+ d0 move d0 long ext d0 sp -) long move word next end-code : s0 sp0 @ ; : save-buffers #buff 1+ 0 do 7fff buffer drop loop ; : sign 0< if 2d hold then ; : smudge latest 20 toggle ; code sp! up bp d) w move 6 w bp di.l) os move \ get sp value 0 os bp di.l) sp lea ( absolute now ) next end-code \ sp@ space spaces swap text then gst850924 code sp@ sp d0 long move bp d0 sub d0 sp -) word move next end-code : space bl emit ; : spaces 0 max ?dup if 0 do space loop then ; code swap sp ) long d0 move d0 swap d0 long sp ) move word next end-code : text here c/l 1+ blank word bl over dup c@ + 1+ c! pad c/l 1+ cmove ; : then ?comp 2 ?pairs here over - swap ! ; immediate \ token toggle traverse type gst850924 : token ( -- addr ) \ get next token from input stream bl word caps @ if dup count >uppercase then ; code toggle sp )+ d0 move sp )+ os move d0 0 os bp di.l) byte eor word next end-code : traverse swap dup c@ 07f < if over + then \ 1st must be 80hex begin over + 07f over c@ < until swap drop ; : type 'type @ execute ; \ type dup 0> if over + swap \ do i c@ emit 1 /loop else 2drop then ; \ u* u. u/mod u< until gst850924 code u* sp )+ d0 move sp )+ d0 mulu d0 sp -) long move word next end-code : u. 0 d. ; code u/mod sp )+ d0 move 0<> if sp )+ d1 long move word d0 d1 divu d1 swap d1 sp -) long move word then next end-code : u< 0 swap 0 d< ; : until 1 ?pairs compile 0branch here - , ; immediate \ update user variable vocabulary warm gst851001 : update prev @ @ 8000 or prev @ ! ; : user constant ;code 2 w bp di.l) d0 move up bp d) d0 add \ d0=(w)+bp d0 sp -) move next end-code : variable create 2 allot ; : vocabulary 'vocabulary @ execute ; : warm 'warm @ execute ; \ finish up cold \ where while word xor gst851223 : where blk @ if blk @ dup scr ! cr cr ." scr# " dup . >in @ 3ff min c/l /mod dup ." line# " . c/l * rot block + cr cr c/l -trailing type >in @ 3ff > + else >in @ then cr here c@ dup >r - here r@ + 1+ c@ 20 = if 1- then spaces r> 0 do 5e emit loop ; : while [compile] if 2+ ; immediate : word 'word @ execute ; code xor sp )+ d0 move d0 sp ) eor next end-code \ [ [compile] ] \ thru gst850924 : [ 0 state ! ; immediate : [compile] ?comp -find not abort" not found" drop cfa , ; immediate : ] c0 state ! ; : \ >in @ c/l / 1+ c/l * >in ! ; immediate : thru 1+ swap do i u. i load loop ; \ chunk.head chunk.size chunk.alloc chunk.end create chunk.head \ chunk header in front of image 0 , 1011 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , here 16384 , ( #longs alloc ) 0 , 1001 , 0 , here 0 , ( chunk size ) constant chunk.size \ size of image in long words constant chunk.alloc \ loader to alloc long # of long words \ you can alter this if you want more \ or less than 64k pre allocated \ for example: limit longs chunk.alloc ! create chunk.end 0 , 1010 , \ written at end of image \ save-forth : save-forth freeze cr cr ." file path name? " pad 80 expect pad 80 new open 2dup or 0= abort" open error" ( keep handle ) 0 coldswitch ! ( allow saved system to cold ) here 7 + 0 4 m/ swap drop chunk.size ! \ size in long words chunk.head a>l 2over 32 rot rot write drop \ chunk head 0 a>l ( from) 4. dnegate d+ ( a few bytes below forth's 0 ) 2over here 7 + -4 and ( align to longs ) \ dfm dhan len rot rot write drop 2dup \ image now out chunk.end a>l 2over 4 rot rot write drop \ chunk end close 1 coldswitch ! drop drop ; \ oldbase var 1var 2var 910512jb ) decimal variable oldbase \ for saving base variable var \ for use as general purpose scratch variables variable 1var variable 2var \ bounds chr >lowercase lowercase 910511jb ) : bounds over + swap ; ( addr len --- addr+len addr ) ( bounds converts an address and a length on the stack into a high and a low address. The I index of a Do Loop will then execute this range of values ) : chr ( --- character -> AsciiNumber ) \ chr A leaves 65 bl word 1+ c@ [compile] literal ; immediate : >lowercase dup dup 64 > swap 91 < and if 32 or then ; : lowercase ( --- ) \ converts current screen to lowercase scr @ block 1024 \ addres and length bounds do i c@ dup chr A < chr Z rot < or not if i c@ 32 + i c! then loop update ; \ base? pause id. vlist empty 910809jb ): base? base @ decimal dup . base ! ; : pause ?terminal if key drop \ pause if any key pressed begin ?terminal until \ wait for next key key 13 = if quit then then ; \ quit if return : id. count 31 and over + swap do i c@ 127 and >lowercase emit loop 32 emit ; : vlist c/l out ! context @ @ begin c/l out @ - over c@ 31 and 4 + < if cr 0 out ! then dup id. 2 spaces pfa 4 - @ dup not pause ?terminal or until drop ; : empty init-forth @ ' forth 2+ ! init-user up @ 6 + 48 cmove ; \ endif >body esc csi beep eeos eeol xycur colm 910511jb ) : endif [compile] then ; immediate : >body ( cfa -- pfa ) 2+ ; : esc 27 emit ; : csi 155 emit ; : beep 7 emit ; : eeos csi 74 emit ; : eeol csi 75 emit ; : xycur ( x y -- ) \ sets cursor to position x y on screen csi 1 .r 59 emit 1 .r 72 emit ; : colm 13 emit eeol " +-------------------------------" type " -------------------------------+" type ; \ bmove hex. >binary 910512jb ) : bmove ( from-addr to-addr length --- ) rot rot 2dup u< if rot <cmove else rot cmove then ; : hex. base @ swap hex 0 d. base ! ; : >binary convert ; \ copy copytofileN screens2file0 910511jb ) decimal \ Caution ! The destination screen will be overwritten! : copy offset @ + swap block 2- ! update ; : copytofileN ( FromScreen ToScreenFileN FileN --- ) \ e.g. copies from-scr of the current file to \ to-scr of the destination file number N 1000 * + swap block 2- ! update ; : screens2file0 ( firstscreen lastscreen -- ) \ copies screens of current file to the \ corresponding screen numbers of file0 1+ swap do i dup . dup block 2- ! update loop ; \ .index index (page) 's .s 910511jb ) : .index dup cr 4 .r 2 spaces block disk-error @ if drop else c/l -trailing type then ; : index cr 1+ swap do i .index pause ?terminal disk-error @ or if leave then loop space ; : (page) 12 emit ; ' (page) cfa 'page ! : 's sp@ ; : .s cr depth if sp@ s0 2- do i @ 0 d. -2 +loop else ." empty stack" then cr ; \ >= <> <= u> erase flush h u.r ['] um* 910511jb ) : >= < 0= ; ( n1 n2 -- bool ) : <> = 0= ; : <= > 0= ; : u> swap u< ; : erase 0 fill ; : flush save-buffers ; : h dp ; : u.r 0 swap d.r ; : ['] ?comp [compile] ' ; immediate : um* u* ; \ forth-83 uses um* \ executetext printerclosed printit 910530jb ) : executetext ( addr -- ) \ place string address in tib and blk @ >r >in @ >r \ execute text as if coming from key board 0 blk ! 0 >in ! tib ! interpret s0 tib ! r> >in ! r> blk ! ; variable printerclosed 1 printerclosed ! : printit ( addr count --- ) \ print out on printer as file 4 printerclosed @ if 0 printerclosed ! " file# 4 dup closefile select from prt: select" ( leaves: addr count ) drop executetext then 4 filehandle 2@ or if >r a>l r@ 4 filehandle 2@ write r> - abort" printing error " else ." No printer channel !!" quit then ; \ cmd 1bl 2bl 2w crlf ffeed resetprinter 910809jb ) hex : cmd create , does> 2 printit ; \ for panasonic kx-p1091i printer and possibly others 0020 cmd 1bl 2020 cmd 2bl 000e cmd 2w \ double width 0d0a cmd crlf 000c cmd ffeed 1b63 cmd resetprinter decimal \ printpad printscreen triad 910511jb ) hex : printpad ( --- ) pad 4a ( 74 ) printit crlf ; : printscreen ( screen# -- ) dup scr ! crlf 2w " Screen # " printit 0 <# #s #> printit 2bl 2bl file# filename count printit crlf 2w " --------------------------------" printit crlf 10 0 do i a < if 1bl then 2bl 2bl i 0 <# #s #> printit 2bl i c/l * scr @ block + c/l printit crlf loop 2w " --------------------------------" printit crlf crlf ; : triad ( scr# --- ) resetprinter 0 3 u/mod swap drop 3 * 3 over + swap do i printscreen loop ffeed ; decimal \ flist 910530jb ) : flist ( --- ) \ vlist formatted in 4 columns for printer resetprinter crlf 0 out ! 0 1var ! ( linecount) context @ @ begin dup out @ 0= if pad 74 32 fill 0 var ! then count 31 and over + swap do i c@ 127 and >lowercase dup bl < if drop bl then pad out @ + c! 1 out +! loop 18 var +! var @ dup out ! 72 = if 0 out ! 2bl 2bl printpad 1 1var +! 1var @ 56 > if ffeed 0 1var ! then then pfa lfa @ dup not pause ?terminal or until drop ; \ printindex 910513jb ) hex : printindex ( screen# screen# --- ) resetprinter crlf 2w " Index of " printit file# filename count printit crlf 1+ swap do i a < if 1bl then i 64 < if 1bl then 2bl 2bl i 0 <# #s #> printit 2bl i block c/l printit crlf loop ; decimal \ begincase case endcase 910511jb ) decimal 5 constant begincase immediate : case compile over compile = [compile] if compile drop ; immediate : endcase begin dup 5 - while [compile] then repeat drop ; immediate \ : test ( n -- ) begincase \ 0 case ." zero " else \ 2 case ." two " else \ -1 case ." minus one " else \ 7 case ." seven " else \ ." non existing case " drop \ endcase ; \ dump 910517jb ) hex : dump base @ oldbase ! hex cr cr over 0f and ." address" dup 4 0 do dup 0f and 5 .r 2 + loop space 4 0 do dup 0f and 5 .r 2 + loop drop 7 spaces 10 0 do dup 0f and 0 <# # #> type 1+ loop drop cr bounds do 5 spaces i 0 <# # # # # #> type 3 spaces i 10 0 do i over + c@ 0 <# # # #> type i 2 mod if space then i 7 = if space then loop 3 spaces 10 0 do i over + c@ 7f and 20 max 7f over = if drop 20 then emit loop cr drop pause ?terminal if leave then 10 +loop oldbase @ base ! ; decimal \ ?words for decompiler 910527jb ) vocabulary decompiler immediate decompiler definitions hex : ?constant ( pfa --- ? ) cfa @ 1e88 = ; : ?variable ( pfa --- ? ) cfa @ 1f9e = ; : ?user ( pfa --- ? ) cfa @ 2b76 = ; : ?<."> ( pfa --- ? ) ' <."> = ; : ?<abort"> ( pfa --- ? ) ' <abort"> = ; : ?<loop> ( pfa --- ? ) ' <loop> = ; : ?<+loop> ( pfa --- ? ) ' <+loop> = ; : ?branch ( pfa --- ? ) ' branch = ; : ?0branch ( pfa --- ? ) ' 0branch = ; : ?typing ( pfa --- ? ) dup ?<."> swap ?<abort"> or ; : ?branching ( pfa --- ? ) dup ?<loop> over ?<+loop> or over ?branch or swap ?0branch or ; decimal \ --v 910527jb ) hex : --v begin cr dup u. ." " dup @ >body dup nfa id. dup ' lit = if ." = " swap 2+ dup @ . else dup ?typing if space 22 emit space swap 2+ dup count type 22 emit dup c@ 2/ 2* + else dup ?branching if ." --> " swap 2+ dup dup @ + u. else dup ' compile = if ." : " swap 2+ dup @ >body nfa id. else swap endif endif endif endif 2+ swap ' exit = pause ?terminal or until drop cr ; decimal \ --h 910527jb ) hex : --h begin out @ 32 > if cr then dup @ >body dup nfa id. dup ' lit = if ." = " swap 2+ dup @ . else dup ?typing if space 22 emit swap 2+ dup count type 22 emit space dup c@ 2/ 2* + else dup ?branching if ." --> " swap 2+ dup dup @ + u. else dup ' compile = if ." : " swap 2+ dup @ >body nfa id. else swap endif endif endif endif 2+ swap ' exit = ?terminal or until drop cr ; decimal \ --1 -- --- 910527jb )hex : --1 cr [compile] ' dup nfa c@ 40 and if ." Immediate " endif dup dup cfa @ = if ." Code Word " drop else dup ?user if ." User Variable " @ . else dup ?constant if ." Constant = " @ . else dup ?variable if ." Variable = " @ . else var @ if --h else --v endif endif endif endif endif ; decimal forth forth definitions : -- decompiler 0 var ! --1 forth ; \ decompile vertically : --- decompiler 1 var ! --1 forth ; \ decompile horizontally \ du< d2/ d- d0= d0< d= d> d@ d* 910530jb ) base @ hex : du< >r >r 8000 + r> r> 8000 + d< ; : d2/ ( d1 --- d2 ) swap 2/ over 1 and if 8000 or else 7fff and then swap 2/ ; base ! : d- dnegate d+ ; : d0= or 0= ; : d0< swap drop 0< ; \ test for d negative : d= d- d0= ; : d> 2swap d< ; : d@ 2@ ; : d* ( d1 d2 --- d1*d2 ) over 5 pick u* 6 roll 4 roll * + 2swap * + ; \ 2rot 2constant 2variable dmin dmax ud. 910517jb ) : 2rot >r >r 2swap r> r> 2swap ; : 2constant create , , does> dup 2+ @ swap @ ; : 2variable create 4 allot ; : dmin 2over 2over d< not if 2swap then 2drop ; : dmax 2over 2over d< if 2swap then 2drop ; : ud. <# #s #> type space ; \ re-forth : re-forth ( --- ??? ) \ re-enter forth for 1 line >in @ >r \ save input buffer pointer blk @ >r \ save block number 0 >in ! 0 blk ! \ reset for terminal input query interpret \ get 1 line from terminal r> blk ! \ restore block number r> >in ! ; \ restore input buffer pointer ( re-forth reenters the forth interpreter from the terminal and allows the user to enter 1 line of valid forth commands. This is a simple way to prompt for terminal messages while in the middle of loading. ) \ Amiga cursor control 910509jb ) base @ decimal : esc 27 emit ; : csi 155 emit ; : insertchar csi 64 emit ; : bs 8 emit ; : curup csi 65 emit ; : tab 9 emit ; : curdown csi 66 emit ; : lfcr 10 emit ; : curfwd csi 67 emit ; : vt 11 emit ; : curback csi 68 emit ; : page 12 emit ; : home csi 72 emit ; : cr 13 emit ; : eeos csi 74 emit ; : so 14 emit ; : eeol csi 75 emit ; : si 15 emit ; : insertline csi 76 emit ; : delline csi 77 emit ; : scrolup csi 83 emit ; : scroldown csi 84 emit ; : delchar csi 127 emit ; : xycur ( x y --- ) csi 1 .r 59 emit 1 .r 72 emit ; base ! \ pythagorean integers \ pytint finds the lengths of the three sides such that \ all lengths are integers. forget job : job ; : pytint 100 1 do i dup dup * \ square of first side 100 i do dup i dup * + \ sum of squares two sides 142 i do dup i dup * - \ minus square of hypothenus dup 0= if cr i j 6 pick 9 .r 9 .r 9 .r then 0< if leave then loop drop loop drop drop loop cr ;
